COMMENT ⊗   VALID 00008 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	begin "mf" comment The METAFONT processor.
C00006 00003	Error handling procedures: quit,error,backerror,overflow,confusion
C00014 00004	Dynamic memory allocation: links,memsize,vmemsize,mem,vmem,memreal,vmemint
C00017 00005	Partial field macros: field,ufield,link,info,setfield...setinfo
C00021 00006	Memory allocation: getavail, getvavail, freeavail, dslist
C00024 00007	Memory, continued: checkmem, searchmem
C00029 00008	Getting the whole thing started properly
C00036 ENDMK
C⊗;
begin "mf" comment The METAFONT processor.

This processor is in four parts:

1. The present module contains routines for memory management,
	initialization, and external control (getting things
	started and stopped gracefully).
2. The MFNTRP module, compiled separately, contains routines 
	for scanning and interpreting the input.
3. The MFRAST module, compiled separately, contains routines
	for raster manipulations (drawing characters).
4. The MFOUT module, compiled separately, contains routines
	for outputting the characters to font files.
	(Substitution of a different MFOUT module will prepare fonts
	for different sets of devices.)

There is an independently running program MFPRE that does the preprocessing
necessary to compute the initial state of METAFONT's hash table and dynamic memory.

There is also a MFHDR file that contains all the declarations of
variables used by more than one module.

It is wise to look at the first page of MFHDR before reading the
following code, since MFHDR introduces a few abbreviations that are
used throughout the METAFONT programs.

Historical notes: A prototype version of METAFONT, containing the raster
manipulation routines only (so that all characters were drawn via explicit
subroutine calls) was developed by D. E. Knuth in the summer of 1977 and used
to design approximately 400 characters during the fall and winter of 1977/1978. This
experience led to the design of the METAFONT language, and a complete METAFONT
system took shape in the latter part of 1978. The present code is the original
December 1978 version with certain changes logged in file DEBUG.LOG;

require "MFHDR.SAI" source_file;
require "MFNTRP.REL" load_module;
require "MFRAST.REL" load_module;
require "MFOUT.REL" load_module;

comment To compile METAFONT with the BAIL debugger, make sure that DEBUGONLY
is defined to be ⊂⊃ in MFHDR, then do "com mtntrp(27b,)" and
"com mfrast(27b,)" and "com mfout(27b,)" and finally "try mfpre/nosai",
"try mfsys/nosai".
To compile METAFONT without BAIL, make sure that DEBUGONLY is defined to be
⊂comment⊃ in MFHDR, then do "com mfntrp,mfrast,mfout" and "ex mfpre/nosai",
"ex mfsys/nosai";
comment Error handling procedures: quit,error,backerror,overflow,confusion;

label end_of_MF,final_end;
internal procedure quit # closes output files and terminates METAFONT;
begin integer c;
DEBUGONLY print(nextline,"Quitting. Do you want a chance to see the memory?");
DEBUGONLY c←inchrw;
DEBUGONLY if c="y" then bail;
control←control land (lnot '4000) # now tfmmode is false,
	therefore no more calls on the error procedure will be made;
go to end_of_MF;
end;

internal boolean pausing_on_errors # should METAFONT wait after error messages?;
internal boolean not_nonstop # should METAFONT wait for other reasons?;
integer errcnt # the number of errors that METAFONT didn't wait after;
internal boolean deletions_allowed # is it safe for error routine to call getnext?;

internal procedure error(string s) # prints an error message;
begin comment The string s explains the type of error. This is displayed to the
user and then the current source code position is indicated;
print(nextline,"! ",s,".");
dumpcontext # prints indication of where the scanner is now;
if pausing_on_errors then
  loop	begin integer c;
	print("↑") # prompt the user;
	clrbuf # if user was typing ahead, clear the system buffer;
	c←inchrw # wait for user to type a character;
	setprint(null,"F"); print(c&null); setprint(null,"B") # echo on ERRORS.TMP;
	IFTENEX if c='37 then return; 
	ELSEC if c='15 then begin c←inchrw # ignore the line-feed; return end;
	ENDC
	if c>'140 then c←c-'40 # change lower case to upper case;
	if c="C" then return;
	if c='12 or c="S" then begin pausing_on_errors←false; return end;
	if c='14 or c="F" then begin pausing_on_errors←not_nonstop←false; return end;
	IFWAITS if curfile and (c="E" or c="T") then
		begin comment abort and enter the system editor;
		setprint(null,"N") # close the errors file;
		edfile(curfile,curfline,curfpage);
		end; ENDWAITS
	IFTOPS20 # this code due to DRF;
	if curfile and (c="E" or c="T") then
		begin string s; integer i;
		setprint(null,"N") # close the errors file;
		s←"ED "&'15&'33&"X Fi"&'33&curfile&'15
			# ED cr esc X FIND FILE esc curfile cr;
		s←s&'33&"X↑R Goto B"&'15
			# esc X ↑R GOTO BEGINNING cr;
		s←s&'25&cvs(curfpage-1)&'33&"X↑R Char"&'15&'14
			# cntl-u <page no> esc X ↑R CHARACTER SEARCH cr cntl-L;
		s←s&'33&"1"&'33&"X↑R Rev"&'33&"C"&'15&'14
			# esc 1 esc X ↑R REVERSE CHARACTER SEARCH cr cntl-L;
		s←s&'25&cvs(curfline-1)&'33&"X↑R Down R"&'15
			# cntl-u <line no> esc X ↑R DOWN REAL LINE cr;
		for i←1 thru length(s) do sti('101,s[i for 1]) # magic ;
		go to final_end;
		end;
	ENDTOPS20

	if c="I" then
		begin pushinput;
		print(nextline,"*"); inbuf←inchwl # wait for user to type a line;
		setprint(null,"F"); print(inbuf&'15); setprint(null,"B") # echo it;
		curbuf←inbuf; filename←null; loc←recovery←0;
		return;
		end;
	if c≥"1" and c≤"9" and deletions_allowed then
		begin integer i; i←c-"0";
		while i>0 do
			begin getnext # recursive call shouldn't happen;
			i←i-1;
			end;
		dumpcontext # print new scanner status;
		continue;
		end;
	DEBUGONLY if c="B" then
	DEBUGONLY	begin bail;
	DEBUGONLY	return;
	DEBUGONLY	end;
	if c="X" then
		begin print(nextline,"Type x again to exit:");
		clrbuf; c←inchrw;
		if c="x" or c="X" then quit;
		end;
	print(nextline,"Type c or C to continue, s or S to scroll all error messages,");
	if deletions_allowed then print(nextline,
		"	1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
	print(nextline,"	i or I to insert something,");
	IFWAITS if curfile then print(" e or E to edit,"); ENDWAITS
	IFTOPS20 if curfile then print(" e or E to edit,"); ENDTOPS20
	print(" x or X to quit.",nextline);
	end
else begin
	errcnt←errcnt+1;
	if errcnt≥100 then
		begin print(nextline,"(That makes 100 errors, I'm tired of this.)");
		quit;
		end;
	end;
end;

internal procedure errorstop(string s) # prints message and dies;
begin pausing_on_errors←false;
error(s);
quit;
end;

ifc ENABLED thenc
simple procedure arithoflow;
begin 
print(nextline, "!An arithmetic exception has occurred!");
end;
endc

internal procedure reportoverflow(string s; integer n)
	# for fatal errors when a METAFONT table is undersized;
errorstop("METAFONT capacity exceeded, sorry ["&s&"="&cvs(n)&"]");

internaldef overflow(s)=⊂reportoverflow("s",s)⊃ # specifies inadequate table size;
internal procedure memoverflow; overflow(memsize);
internal procedure vmemoverflow; overflow(vmemsize);

internal procedure confusion # METAFONT consistency check failure;
errorstop("This can't happen");
comment Dynamic memory allocation: links,memsize,vmemsize,mem,vmem,memreal,vmemint;

comment METAFONT does nearly all of its own memory allocation, so that it can
readily be transported into environments that do not have automatic
facilities for strings, garbage collection, etc. The dynamic storage
requirements of METAFONT are handled by providing a large integer array "mem" 
and a smaller real array "vmem". Pointer variables are indices into these arrays.
When a pointer value p is less than vmemsize, it essentially is pointing to a
two-word node (mem[p], vmem[p]). When p is ≥ vmemsize, it essentially points to
the one-word node mem[p].

Separate available-space lists are maintained for two-word nodes and one-word
nodes. In an emergency, a two-word node will be temporarily assigned to one-word
duty.
;
internaldef links = 13 # number of bits per pointer;
internaldef memsize=8192 # size of dynamic list memory, must be ≤ 2↑links;
internaldef vmemsize=2500 # size of two-word list memory, must be << memsize;
comment MFHDR contains the true values of these volatile parameters;

comment saf integer array mem[0:memsize-1] # dynamic list memory;
comment saf real array vmem[0:vmemsize-1] # two-word list memory;
comment mem and vmem have been made internal to MFNTRP, for the sake of more
efficient code;

internaldef memreal(p)=⊂memory[location(mem[p]),real]⊃ # mem[p] as type real;
internaldef vmemint(p)=⊂memory[location(vmem[p]),integer]⊃ # vmem[p] as integer;

SHOWMEM internal integer oneused,twoused # how much memory is in use;
comment Partial field macros: field,ufield,link,info,setfield...setinfo;

comment The following macros are for accessing and modifying partial fields
of packed words. If f is a field name, then fs denotes its size in bits
and fd denotes its displacement from the right of the word. These sizes and
displacements are defined at compile time--e.g.,"links" for size of link fields.
In the following definitions, x denotes the word being modified and y denotes
a new value to be inserted into the specified field (it must not be too
large for the field). The definitions look inefficient, but they take
advantage of the fact that SAIL does a lot of local optimization;


internaldef fs(f) = ⊂f⊃&"s" # field size of f, in bits;
internaldef fd(f) = ⊂f⊃&"d" # field displacement of f, in bits;

internaldef field(f,x) = ⊂ifc fd(f)=0 thenc ((x) land (2↑fs(f)-1))
	elsec ifc fs(f)+fd(f)≥bitsperwd thenc ((x) lsh -fd(f))
	elsec (((x) lsh -fd(f)) land (2↑fs(f)-1)) endc endc⊃ # field f of x;

internaldef setfield(f,x,y) = ⊂ifc fd(f)=0 thenc x←(x land(-2↑fs(f)))+(y)
	elsec ifc fs(f)+fd(f)≥bitsperwd thenc 
		x←((x lsh(bitsperwd-fd(f)))+(y))rot fd(f)
	elsec x←(((x rot -fd(f))land(-2↑fs(f)))+(y))rot fd(f) endc endc⊃
		# sets field f of x equal to y, 0 ≤ y < 2↑fs(f);

comment Sometimes an unshifted field is desired. For this purpose, we use
ufield instead of field, and deal with values times 2↑fd;

internaldef ufield(f,x) = ⊂((x) land((1 lsh(fs(f)+fd(f)))-2↑fd(f)))⊃
		# unshifted field f of x;
internaldef setufield(f,x,y) = ⊂x←(x land lnot((1 lsh(fs(f)+fd(f)))-2↑fd(f)))+(y)⊃
		# field f of x set to unshifted value y;

comment The special case of a pointer field at the right of a word is
most common, so there are special conventions for it. When p is a pointer,
we write link(p) for the pointer field of mem[p] and info(p) for the
(shifted) remaining fields of the word;

internaldef linkd = 0 # displacement of link field;
internaldef link(p) = ⊂field(link,mem[p])⊃ # link field of mem[p];
internaldef setlink(p,y) = ⊂setfield(link,mem[p],y)⊃ # sets link(p)←y;
internaldef infod = links, infos = bitsperwd-infod # definition of info field;
internaldef info(p) = ⊂field(info,mem[p])⊃ # info field of mem[p];
internaldef setinfo(p,y) = ⊂setfield(info,mem[p],y)⊃ # sets info(p)←y;

DEBUGONLY integer procedure lk(integer x);
DEBUGONLY return(x land(2↑links-1)) # link field of packed word;
DEBUGONLY integer procedure fo(integer x);
DEBUGONLY return(x lsh -infod) # info field of packed word;
comment Memory allocation: getavail, getvavail, freeavail, dslist;

comment	The dynamic memory is accessed via three simple macros:
	getavail(p) makes p point to a new one-word node,
	gettavail(p) makes p point to a new two-word node,
	freeavail(p) returns node p to storage.
;
internal integer avail # head of available space list for one-word nodes;
internal integer vavail # head of available space list for two-word nodes;
internaldef getavail(p) = ⊂begin if(p←avail)then
	begin avail←mem[avail]: SHOWMEM oneused←oneused+1: end
	else if(p←vavail)then
	begin vavail←mem[vavail]: SHOWMEM twoused←twoused+1: end
	else memoverflow: end⊃ # p ← new one-word node;
internaldef getvavail(p) = ⊂begin if(p←vavail)then vavail←mem[vavail]
	else vmemoverflow: SHOWMEM twoused←twoused+1: end⊃ # p ← new two-wd node;
internaldef freeavail(p) = ⊂if p<vmemsize then
	begin mem[p]←vavail: vavail←p: SHOWMEM twoused←twoused-1: end
	else begin mem[p]←avail: avail←p: SHOWMEM oneused←oneused-1: end⊃
		# node p now available;

comment The following procedure can be used to free up an entire linked list;
internal procedure dslist(integer p) # makes list of nodes available;
begin integer q # pointer to node following node p;
while p do
	begin q←link(p); freeavail(p); p←q;
	end;
end;
comment Memory, continued: checkmem, searchmem;

comment There are also two procedures that may come in handy when diagnosing
mysterious errors;

DEBUGONLY integer array free[0:memsize-1];
DEBUGONLY internal procedure checkmem(boolean printlocs) # checks links in mem;
DEBUGONLY begin comment This procedure checks the format of the available space
DEBUGONLY lists and (if printlocs is true) prints those locations of mem that were
DEBUGONLY free the last time this procedure was called but reserved now.
DEBUGONLY All nodes should be returned to the avail lists when METAFONT is done with
DEBUGONLY them, and checkmem can be used to check if this has been done correctly;
DEBUGONLY integer p,i;
DEBUGONLY p←avail;
DEBUGONLY while p do
DEBUGONLY 	begin if (mem[p]≥memsize) or (free[p] land 1) or
DEBUGONLY		(mem[p]≠0 and mem[p]<vmemsize) then
DEBUGONLY 		begin print(nextline,"avail list clobbered at ",p);
DEBUGONLY		bail;
DEBUGONLY		done;
DEBUGONLY 		end;
DEBUGONLY 	free[p]←free[p] lor 1;
DEBUGONLY 	p←mem[p];
DEBUGONLY 	end;
DEBUGONLY p←vavail;
DEBUGONLY while p do
DEBUGONLY 	begin if (mem[p]≥vmemsize) or (free[p] land 1) or (mem[p]<0) then
DEBUGONLY 		begin print(nextline,"vavail list clobbered at ",p);
DEBUGONLY		bail;
DEBUGONLY		done;
DEBUGONLY 		end;
DEBUGONLY 	free[p]←free[p] lor 1;
DEBUGONLY 	p←mem[p];
DEBUGONLY 	end;
DEBUGONLY if printlocs then print(nextline,"New busy locs: ");
DEBUGONLY for i←0 thru memsize-1 do
DEBUGONLY 	begin if free[i] land 3 = 2 and printlocs then print(i," ");
DEBUGONLY 	free[i]←free[i] lsh 1;
DEBUGONLY 	end;
DEBUGONLY end;

DEBUGONLY procedure searchmem(integer p) # finds pointers to p;
DEBUGONLY begin integer i;
DEBUGONLY for i←0 thru memsize-1 do
DEBUGONLY 	begin if link(i)=p then print(nextline,"link(",i,")");
DEBUGONLY 	if name(i)=p then print(nextline,"name(",i,")");
DEBUGONLY 	end;
DEBUGONLY for i←0 thru vmemsize-1 do
DEBUGONLY	begin
DEBUGONLY 	if field(link,vmemint(i))=p then print(nextline,"vlink(",i,")");
DEBUGONLY	if field(info,vmemint(i))=p then print(nextline,"vinfo(",i,")");
DEBUGONLY 	end;
DEBUGONLY for i←0 thru hashsize-1 do if hashh[i]=p then
DEBUGONLY	print(nextline,"link in hash[",i,"]");
DEBUGONLY end;

comment A few words of the memory are dedicated to fixed usage. Location mem[0]
is used during elementary list manipulations, and location wvar (the one-word
node) is the list head for w-variables;
internaldef wvar = memsize-1 # head of list for w-variables;
internaldef depvar = wvar-1 # head of list for dependent variables;
internaldef temphead = depvar-1 # temporary list head for created lists;
internaldef main = ⊂1⊃ # area header for main program;
internaldef firstvmem = 2, lastmem = temphead-1 # nodes not specially dedicated;
comment Getting the whole thing started properly;

preload_with true; safe boolean array notalreadyinitialized[0:0];

string cmdline, errorfilname;
comment The declarations have now ended, METAFONT starts here after being loaded;
if notalreadyinitialized[0] then
	begin integer chan;
	notalreadyinitialized[0]←false;
	open(chan←getchan,"DSK",'10,2,0,0,0,eof);
	lookup(chan,"MFINI.TBL", eof);
	if eof or wordin(chan)≠hashsize or wordin(chan)≠vmemsize
		or wordin(chan)≠memsize then
		begin print("MFINI.TBL is clobbered!");
		go to final_end;
		comment If this error happens, execute MFPRE to recreate the file;
		end;
	hptr←wordin(chan);
	arryin(chan,hashh[0],hashsize);
	arryin(chan,hname[0],hptr);
	arryin(chan,mem[0],memsize);
	arryin(chan,vmem[0],vmemsize);
	avail←wordin(chan);
	vavail←wordin(chan);
	release(chan);
	SHOWMEM oneused←twoused←0;
	pausing_on_errors←true; not_nonstop←true; deletions_allowed←true;
 	errcnt←0;
	comment If TENEX, we must wait and allocate the raster when the
		core image is invoked, else the dynamically allocated
		array goes away on us.  But at Sail, we can clear the
		statically allocated raster now;
	IFWAITS arrclr(rast); ENDWAITS
	xleft←ylow←infty; xright←yhigh←-infty # clear the raster;

	outstr("OK, METAFONT's tables have been initialized. "&
		"Please SAVE the core image.");
	IFWAITS ptostr(0,"SAVE mf") # this is what the user
		probably wants to do next; ENDWAITS
	go to final_end;
	end;

define defaulterrorfilname=⊂"errors.tmp"⊃;
IFTENEX redefine defaulterrorfilname=⊂"errors.tmp;t"⊃; ENDTENEX
errorfilname←defaulterrorfilname;
IFTENEX
	begin comment Now for the magic that dynamically allocates a 
		raster array for us.  You might want to check out page
		65 of the Sail manual, by the way;
	external integer procedure armak(integer lb,ub,dims);
	rastptr←new_record(rastrec);
	memory[location(rast)]←armak(rast0,rast1,1);
	arrclr(rast);
	end;
ENDTENEX
initin # initialize the input system;
initout # initialize the output system;
ifc ENABLED thenc trigini(location(arithoflow)); endc
IFXMEM initxmem; ENDXMEM
IFTOPS20
begin "getcommandline"
	string s; integer i;
	start_code
	    setz  1,0;
	    jsys  '500;	haltf;
	    end;
	s←intty # gets the users command line that started up MF;
	while length(s)>0 and s[1 for 1] neq " " do i←lop(s);
	while length(s)>0 and s[1 for 1] = " " do i←lop(s);
	if s[inf for 1]="/" then
		begin s←s[1 to inf-1];
		pausing_on_errors←false # this job is to be run in batch mode;
		not_nonstop←false # so it shouldn't stop for any reason;
		end;
	cmdline←s;
	while length(s)>0 and s[inf for 1] = " " do s←s[1 to inf-1];
	if length(s)>0 then begin integer j,k,l;
		comment j->space before last word, k->end of penultimate word,
				l->space before penultimate word;
		j←length(s); while (j>0) and (s[j for 1] neq " ") do j←j-1;
		k←j; while (k>0) and (s[k for 1] = " ") do k←k-1;
		l←k; while (l>0) and (s[l for 1] neq " ") do l←l-1;
		if equ(s[l+1 to k],"input") then begin string ss;
			ss←s[j+1 to inf];
			i←1; while i leq length(ss) do
				if ss[i for 1]=":" or ss[i for 1]=">"
				then begin ss←ss[i+1 to inf]; i←1; end
				else if ss[i for 1]="." then ss←ss[1 to i-1]
				else i←i+1;
			errorfilname←ss&".ERR";
			end;
		end;
	end "getcommandline";
ENDTOPS20

setformat(0,4) # controls format of cvf in diagnostic routine "dumplist";
setprint(errorfilname,"B") # printing goes to file as well as terminal;
IFTENEX print(nextline,"TENEX METAFONT 4.0 of December 1, 1980",nextline); ENDTENEX
IFTOPS20
if cmdline then begin
	curbuf←inbuf←cmdline&'15 # cr deleted by system;
	setprint(null,"F"); print(inbuf&'12); setprint(null,"B");
	end;
ENDTOPS20
maincontrol # transfer power to the chief executive;

end_of_MF:
IFXMEM closexmem; ENDXMEM
closeout # close output files of MFOUT;
if bbuf then print(nextline,"(binput file still contains unread data)");
setprint(errorfilname,"N") # close print output file;
final_end: end "mf"